home *** CD-ROM | disk | FTP | other *** search
/ MacFormat 1994 November / macformat-018.iso / Utility Spectacular / Developer / macgambit-20-compiler-src-p2 / Thomas / run-collections-array.scm < prev    next >
Encoding:
Text File  |  1994-07-26  |  12.1 KB  |  335 lines  |  [TEXT/gamI]
  1. ;*              Copyright 1992 Digital Equipment Corporation
  2. ;*                         All Rights Reserved
  3. ;*
  4. ;* Permission to use, copy, and modify this software and its documentation is
  5. ;* hereby granted only under the following terms and conditions.  Both the
  6. ;* above copyright notice and this permission notice must appear in all copies
  7. ;* of the software, derivative works or modified versions, and any portions
  8. ;* thereof, and both notices must appear in supporting documentation.
  9. ;*
  10. ;* Users of this software agree to the terms and conditions set forth herein,
  11. ;* and hereby grant back to Digital a non-exclusive, unrestricted, royalty-free
  12. ;* right and license under any changes, enhancements or extensions made to the
  13. ;* core functions of the software, including but not limited to those affording
  14. ;* compatibility with other hardware or software environments, but excluding
  15. ;* applications which incorporate this software.  Users further agree to use
  16. ;* their best efforts to return to Digital any such changes, enhancements or
  17. ;* extensions that they make and inform Digital of noteworthy uses of this
  18. ;* software.  Correspondence should be provided to Digital at:
  19. ;*
  20. ;*            Director, Cambridge Research Lab
  21. ;*            Digital Equipment Corp
  22. ;*            One Kendall Square, Bldg 700
  23. ;*            Cambridge MA 02139
  24. ;*
  25. ;* This software may be distributed (but not offered for sale or transferred
  26. ;* for compensation) to third parties, provided such third parties agree to
  27. ;* abide by the terms and conditions of this notice.
  28. ;*
  29. ;* THE SOFTWARE IS PROVIDED "AS IS" AND DIGITAL EQUIPMENT CORP. DISCLAIMS ALL
  30. ;* WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF
  31. ;* MERCHANTABILITY AND FITNESS.   IN NO EVENT SHALL DIGITAL EQUIPMENT
  32. ;* CORPORATION BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL
  33. ;* DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR
  34. ;* PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS
  35. ;* ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS
  36. ;* SOFTWARE.
  37.  
  38. ; $Id: runtime-collections-array.scm,v 1.17 1992/09/08 11:15:05 birkholz Exp $
  39.  
  40. ;;;;; RUNTIME-COLLECTIONS-ARRAY.SCM
  41.  
  42. ;;;;; This file contains all the specializations for array type
  43.  
  44. (add-method dylan:shallow-copy
  45.   (dylan::function->method
  46.     (make-param-list `((ARRAY ,<array>)) #F #F #F)
  47.     (lambda (array)
  48.       (let* ((dimensions (dylan-call dylan:dimensions array))
  49.          (new-array
  50.           (dylan-call dylan:make <array> 'dimensions: dimensions))
  51.          (key-sequence (dylan-call dylan:key-sequence array)))
  52.     (do ((state (dylan-call dylan:initial-state key-sequence)
  53.             (dylan-call dylan:next-state key-sequence state)))
  54.         ((not state)
  55.          (dylan-call dylan:as
  56.              (dylan-call dylan:class-for-copy array)
  57.              new-array))
  58.       (let ((key (dylan-call dylan:current-element key-sequence state)))
  59.         (dylan-call dylan:setter/element/
  60.             new-array
  61.             key
  62.             (dylan-call dylan:element array key))))))))
  63.  
  64.  
  65. (add-method dylan:as
  66.   (dylan::function->method
  67.    (make-param-list `((CLASS ,(dylan::make-singleton <array>))
  68.               (COLLECTION ,<collection>)) #F #F #F)
  69.    (lambda (class collection)
  70.      class
  71.      (if (dylan-call dylan:instance? collection <array>)
  72.      collection
  73.      (let* ((size (dylan-call dylan:size collection))
  74.         (new-array
  75.          (dylan-call dylan:make <array> 'dimensions: (list size)))
  76.         (vector-value (dylan-call dylan:get-array-value new-array)))
  77.        (do ((state (dylan-call dylan:initial-state collection)
  78.                (dylan-call dylan:next-state collection state))
  79.         (index 0 (+ index 1)))
  80.            ((not state) new-array)
  81.          (vector-set! vector-value index
  82.               (dylan-call
  83.                dylan:current-element collection state))))))))
  84.  
  85.  
  86. ;;;
  87. ;;; ARRAY SPECIALIZED MAKE
  88. ;;;
  89.  
  90. ;; All subclasses of ARRAY have slots for the data ("value") and a
  91. ;; list of dimensions ("dimensions").
  92.  
  93. (define dylan:get-array-value "define dylan:get-array-value")
  94. (define dylan:get-array-dimensions "define dylan:get-array-dimensions")
  95. (define dylan:set-array-value! "define dylan:set-array-value!")
  96. (define dylan:set-array-dimensions! "define dylan:set-array-dimensions!")
  97. (create-private-slot <array> <simple-object-vector>
  98.              "internal-array-value"
  99.  (lambda (set get)
  100.    (set! dylan:set-array-value! set)
  101.    (set! dylan:get-array-value get)))
  102. (create-private-slot <array> <list>
  103.              "internal-array-dimensions"
  104.  (lambda (set get)
  105.    (set! dylan:set-array-dimensions! set)
  106.    (set! dylan:get-array-dimensions get)))
  107.  
  108. ;; These four generic operations must be specialized for the special
  109. ;; cases of <byte-string> and <simple-object-vector>
  110.  
  111. (add-method dylan:get-array-value
  112.   (one-arg 'STRING <byte-string> (lambda (string) string)))
  113. (add-method dylan:set-array-value!
  114.   (dylan::function->method
  115.    (make-param-list `((STRING ,<byte-string>) (VALUE ,<object>)) #F #F #F)
  116.     (lambda (string value)
  117.       (dylan-call dylan:error
  118.           "set-array-value! -- internal error on string"
  119.           string value))))
  120. (add-method dylan:get-array-dimensions
  121.   (one-arg 'STRING <byte-string>
  122.     (lambda (string) (list (string-length string)))))
  123. (add-method dylan:set-array-dimensions!
  124.   (dylan::function->method
  125.    (make-param-list `((STRING ,<byte-string>) (VALUE ,<object>)) #F #F #F)
  126.     (lambda (string value)
  127.       (dylan-call dylan:error
  128.           "set-array-dimensions! -- internal error on string"
  129.           string value))))
  130.  
  131. (add-method dylan:get-array-value
  132.   (one-arg 'VECTOR <simple-object-vector>
  133.     (lambda (vector) vector)))
  134. (add-method dylan:set-array-value!
  135.   (dylan::function->method
  136.    (make-param-list `((VECTOR ,<simple-object-vector>)
  137.               (VALUE ,<object>)) #F #F #F)
  138.     (lambda (vector value)
  139.       (dylan-call dylan:error
  140.           "set-array-value! -- internal error on simple-object-vector"
  141.           vector value))))
  142. (add-method dylan:get-array-dimensions
  143.   (one-arg 'VECTOR <simple-object-vector>
  144.     (lambda (vector) (list (vector-length vector)))))
  145. (add-method dylan:set-array-dimensions!
  146.   (dylan::function->method
  147.    (make-param-list `((VECTOR ,<simple-object-vector>)
  148.               (VALUE ,<object>)) #F #F #F)
  149.     (lambda (vector value)
  150.       (dylan-call
  151.        dylan:error
  152.        "set-array-dimensions! -- internal error on simple-object-vector"
  153.        vector value))))
  154.  
  155. (add-method
  156.  dylan:make
  157.  (dylan::dylan-callable->method
  158.   (make-param-list `((ARRAY ,(dylan::make-singleton <array>)))
  159.            #F #F '(dimensions: fill:))
  160.   (lambda (multiple-values next-method class . rest)
  161.     (define (make-multi-dimensional-array dimensions fill)
  162.       (if (null? dimensions)
  163.       (dylan-call dylan:error
  164.               "make -- 0-dimensional arrays not allowed"))
  165.       (let ((result (make-vector (car dimensions) fill)))
  166.     (if (null? (cdr dimensions))
  167.         result
  168.         (do ((n 0 (+ n 1)))
  169.         ((= n (car dimensions)) result)
  170.           (vector-set! result n
  171.                (make-multi-dimensional-array
  172.                 (cdr dimensions)
  173.                 fill))))))
  174.     multiple-values            ; Ignored
  175.     class                ; Ignored
  176.     (dylan::keyword-validate next-method rest '(dimensions: fill:))
  177.     (let ((dimensions
  178.        (dylan::find-keyword rest 'dimensions:
  179.                 (lambda ()
  180.                   (dylan-call dylan:error
  181.                           "make -- array needs dimensions"
  182.                           class rest))))
  183.       (fill-value (dylan::find-keyword rest 'fill: (lambda () #F))))
  184.       (if (not (subclass? (get-type dimensions) <sequence>))
  185.       (dylan-call dylan:error
  186.               "make -- array dimensions not a sequence"
  187.               class dimensions))
  188.       (let ((instance (dylan::make-<object> <array>))
  189.         (dim-list
  190.          (iterate->list
  191.           (lambda (elem)
  192.         (if (not (and (integer? elem)
  193.                   (positive? elem)))
  194.             (dylan-call
  195.              dylan:error
  196.              "make -- dimension elements not all positive integers"
  197.              class dimensions elem)
  198.             elem))
  199.           dimensions)))
  200.     (dylan-call dylan:set-array-value!
  201.             instance
  202.             (make-multi-dimensional-array dim-list fill-value))
  203.     (dylan-call dylan:set-array-dimensions! instance dim-list)
  204.     instance)))))
  205.  
  206. ;;;;
  207. ;;;; Operations on Arrays (page 113 )
  208. ;;;;
  209. (define dylan:aref
  210.   (dylan::generic-fn 'aref
  211.     (make-param-list `((ARRAY ,<array>)) #F #T #F)
  212.     (lambda (array-instance . init-indices)
  213.       (if (null? init-indices)
  214.       (dylan-call dylan:error
  215.               "aref -- no indices given" array-instance))
  216.       (let loop ((array (dylan-call dylan:get-array-value array-instance))
  217.          (indices init-indices))
  218.     (if (vector? array)
  219.         (let ((size (vector-length array))
  220.           (index (car indices)))
  221.           (if (>= index size)
  222.           (dylan-call dylan:error
  223.                   "aref -- subscript out of range"
  224.                   array-instance init-indices array index))
  225.           (if (null? (cdr indices))
  226.           (vector-ref array index)
  227.           (loop (vector-ref array index) (cdr indices))))
  228.         (dylan-call dylan:error
  229.             "aref -- too many subscripts"
  230.             array-instance init-indices indices))))))
  231.  
  232. (define dylan:setter/aref/
  233.   (dylan::generic-fn 'aref
  234.     (make-param-list `((ARRAY ,<array>)) #F #T #F)
  235.     (lambda (array-instance . indices-and-new-value)
  236.       (if (null? indices-and-new-value)
  237.       (dylan-call dylan:error
  238.               "(setter aref) -- no indices and new-value given"
  239.               array-instance))
  240.       (let ((new-value (list-ref indices-and-new-value
  241.                  (- (length indices-and-new-value) 1)))
  242.         (indices (but-last indices-and-new-value)))
  243.     (if (not (pair? indices))
  244.         (dylan-call dylan:error
  245.             "(setter aref) -- no indices given"
  246.             array-instance indices-and-new-value))
  247.     (let loop ((array (dylan-call dylan:get-array-value array-instance))
  248.            (indices indices))
  249.       (if (vector? array)
  250.           (let ((size (vector-length array))
  251.             (index (car indices)))
  252.         (if (>= index size)
  253.             (dylan-call dylan:error
  254.                 "(setter aref) -- subscript out of range"
  255.                 array-instance indices-and-new-value
  256.                 array index))
  257.         (if (null? (cdr indices))
  258.             (if (vector? (vector-ref array index))
  259.             (dylan-call
  260.              dylan:error
  261.              "(setter aref) -- indices need to point to an element"
  262.              array-instance indices-and-new-value array index)
  263.             (begin
  264.               (vector-set! array index new-value)
  265.               new-value))
  266.             (loop (vector-ref array index) (cdr indices))))
  267.           (dylan-call dylan:error
  268.               "(setter aref) -- too many subscripts"
  269.               array-instance indices-and-new-value indices)))))))
  270.  
  271. (define dylan:dimensions
  272.   (dylan::generic-fn 'dimensions
  273.     (make-param-list `((ARRAY ,<array>)) #F #F #F)
  274.     (lambda (array)
  275.       (dylan-call dylan:get-array-dimensions array))))
  276.  
  277. (add-method
  278.  dylan:element
  279.  (dylan::dylan-callable->method
  280.   (make-param-list `((ARRAY ,<array>) (INDEX ,<sequence>)) #F #F '(default:))
  281.   (lambda (multiple-values next-method array-instance init-indices . rest)
  282.     multiple-values
  283.     (dylan::keyword-validate next-method rest '(default:))
  284.     (let* ((default (dylan::find-keyword rest 'default: (lambda () #F)))
  285.        (error-report (lambda args (if default
  286.                       default
  287.                       (apply dylan:error args)))))
  288.       (if (dylan-call dylan:empty? init-indices)
  289.       (error-report "element -- no indices given" array-instance)
  290.       (let loop ((array
  291.               (dylan-call dylan:get-array-value array-instance))
  292.              (index-state
  293.               (dylan-call dylan:initial-state init-indices)))
  294.         (let ((index (dylan-call dylan:current-element
  295.                      init-indices index-state)))
  296.           (if (vector? array)
  297.           (cond ((>= index (vector-length array))
  298.              (error-report "element -- subscript out of range"
  299.                        array-instance init-indices array index))
  300.             ((not
  301.               (dylan-call dylan:next-state
  302.                       init-indices index-state))
  303.              (vector-ref array index))
  304.             (else (loop (vector-ref array index)
  305.                     (dylan-call dylan:next-state
  306.                         init-indices index-state))))
  307.           (error-report "element -- too many subscripts"
  308.                 array-instance init-indices index)))))))))
  309.  
  310. (add-method dylan:current-key
  311.   (dylan::function->method
  312.    (make-param-list `((ARRAY ,<array>) (STATE ,<object>)) #F #F #F)
  313.    (lambda (array state)
  314.      array                ; Ignored
  315.      state)))
  316.  
  317. ;;;
  318. ;;; Mutable Collections
  319. ;;;
  320.  
  321. (add-method dylan:setter/current-element/
  322.   (dylan::function->method
  323.     (make-param-list
  324.      `((ARRAY ,<array>) (STATE ,<object>) (new-value ,<object>)) #F #F #F)
  325.     (lambda (array state new-value)
  326.       array                ; Ignored
  327.       (let loop ((vectors (dylan-call dylan:get-array-value array))
  328.          (state (vector->list state)))
  329.     (if (= (length state) 1)
  330.         (begin
  331.           (vector-set! vectors (car state) new-value)
  332.           new-value)
  333.         (loop (vector-ref vectors (car state))
  334.           (cdr state)))))))
  335.